PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/baseapp.exe/BAPP10.PAS

Pascal/Delphi Source File | 1991-09-15 | 16.1 KB | 437 lines

PROGRAM BasicApp;

{(c) 1991 John C. Leon}

{Version 1.0   9/15/91}

{READ THESE COMMENTS BEFORE USING THIS CODE!}

{This base application was prepared for my personal use, as I do not wish
 to recreate the wheel with each new TV application.  Because I seem to
 always want the same skeleton in my TV apps, this base set of code has become
 very helpful!

 Included in the base app is code for properly handling window numbers,
 enabling a video mode toggle, providing tileable/cascadable windows,
 testing for application-specific conditions before presenting the main
 menu (and showing error message windows if there's a problem), and generating
 a title screen on initialization.

 All windows should be descendants of BWindow.  Your descendants can
 freely modify BWindow.Init and BWindow.Done.  As long as they call
 BWindow.Init and BWindow.Done, you can assure yourself that they will
 be tilable/cascadable, and that window numbers will be properly handled.

 The BaseApp.BaseWindow procedure opens an empty, generic window.  This is
 provided only so that you can see the use of the SetWinCount procedure, and
 so that you can see properly working window numbers.  To test it out, open
 a few windows.  Then close, say, window #2.  Open a new window, and it will
 use #2 (the first available window number).  If only something as basic as
 this was built into TV, eh?

 A generic menubar and statusline are provided, including help contexts.  This
 will be extremely helpful for programmers struggling with how to implement
 help contexts, if like me, you lost a lot of sleep getting it right the
 first time!

 The base app also includes code to put up a message box if the application
 fails to initialize.  That is, if you require certain conditions to be met
 before your user can even start the app (data files must be present, etc)
 you can initialize TV anyway and use a message box to state the cause of
 failure.  For this reason, the base application uses the TVision sample unit
 MSGBOX (a VERY useful set of routines!).  To illustrate how this works, THE
 BASE APP REQUIRES THAT THE SOURCE CODE FILE (or any file named BASEAPP.PAS)
 BE PRESENT IN THE CURRENT DIRECTORY.

 If you find this code helpful, I'd appreciate a whopping $10.  This'll buy
 you copies of any future utilities, versions, etc, and the legal right to
 use this software.  This is SHAREWARE, folks, *NOT* freeware or public
 domain.  Act accordingly.

 Constructive criticism and suggestions always welcome.

 John C. Leon
 3807 Wood Gardens Court
 Kingwood, TX  77339

 CIS 72426,2077

 N.B.  The ColBackground routines (the code to change background color) are
       taken directly from Neil J. Rubenking's book, Turbo Pascal 6.0
       Techniques and Utilities...a MUST for your collection).

       Attention Btrieve programmers!  My object-oriented unit for handling
       standard Btrieve files is available currently as FREEWARE.  Makes
       TP6 Btrieve programming a snap!  It is available on CIS in forum
       BPROGA, library 1 (OOP).  Just browse for file BTP*.ZIP
       (* = version number).

}


USES
   App, Dialogs, Objects, Menus, Views, Drivers, MsgBox;


CONST
   cmSetVideoMode    = 100;
   cmBaseWindow      = 110;
   cmAbout           = 120;
   ErrorInitializing : integer = 0;
   WinCount          : integer = 0;


TYPE
   BaseApp = object(TApplication)
      constructor Init;
      procedure InitMenuBar   ; virtual;
      procedure InitStatusLine; virtual;
      procedure TitleScreen;
      procedure TileAll;
      procedure CascadeAll;
      procedure SetVideoMode;
      procedure BaseWindow;
      procedure HandleEvent(var Event: TEvent); virtual;
      destructor Done; virtual;
      end;

   PColBackground   = ^ColBackground;
   ColBackground    = object(TBackground)
                      Color: Byte;
                      constructor Init(var Bounds: TRect; APat: Char;
                                       AColor: Byte);
                      procedure Draw; virtual;
                      end;

   PHelpStatusLine  = ^THelpStatusLine;
   THelpStatusLine  = object(TStatusLine)
                      function Hint(AHelpCtx: Word): string; virtual;
                      end;

   PWindow       = ^BWindow;
   BWindow       =  object(TWindow)
                    constructor Init(var Bounds: TRect; WinTitle: string;
                                     WinNumber: integer);
                    destructor Done; virtual;
                    end;


VAR
   BApp                : BaseApp;
   WinNumberCollection : PStringCollection; {initialized during BaseApp.Init}
   WinNumberString     : string;
   RequiredFile        : text;  {NOT required for basic app, but is used as
                                 an illustration of message box use if app's
                                 required files/conditions are not met and
                                 you DON'T want user to 'enter' application.}

constructor BaseApp.Init;
var
   R      : TRect;
   Counter: integer;
   Control: word;
begin
   {Set up the collection of window numbers, sorted automatically from 1 to 9.}
   WinNumberCollection := New(PStringCollection, Init(9,0));
   for Counter := 1 to 9 do
      begin
      str(Counter,WinNumberString);
      WinNumberCollection^.Insert(NewStr(WinNumberString));
      end;

  {NOTE: The variable 'ErrorInitializing' MUST be assigned before calling
   TApplication.Init, as TApplication.Init will internally initialize the
   menu and status line.  The base application's overrides of InitMenuBar and
   InitStatusLine depend on ErrorInitializing being assigned.  This location
   in the BaseApp.Init is where you'd put your various app initialization
   tests.  See the case statement below for actions to take on failure of
   your initializations.}
   assign(RequiredFile,'BaseApp.Pas');
   {$I-} reset(RequiredFile); {$I+}
   if ioresult <> 0 then
      ErrorInitializing := 1;

   {Call ancestor.}
   TApplication.Init;

   {Replace background with one of new color.  Credit to Neil J. Rubenking's
    book, Turbo Pascal 6.0 Techniques and Utilities for this code.}
   Desktop^.Background^.GetExtent(R);
   Desktop^.Delete(Desktop^.Background);
   Dispose(Desktop^.Background, done);
   Desktop^.Background := New(PColBackground, Init(R, #176, 9));
   Desktop^.Insert(Desktop^.Background);

   {No windows open at initialization, so disable the Tile and Cascade cmds
    on menu.}
   DisableCommands([cmTile, cmCascade]);

   {Universally turn off the Video Mode option on menu if user screen can't
    handle it.}
   if HiResScreen = false then
     DisableCommands([cmSetVideoMode]);

   {Put up a generic title screen.  Note what's done if there's an error
    initializing your app.  Expand this case statement as required to put
    up different messages depending on which of you application's requirements
    was not met.}
   case ErrorInitializing of
      0: TitleScreen;
      1: Control := MessageBox(^C'Required file not found'^M^C'Cannot run Base App',
                                nil, mfError + mfOKButton);
      end;
end;

destructor BaseApp.Done;
begin
   TApplication.Done;
   dispose(WinNumberCollection, Done); {Call this AFTER calling ancestor!}
end;

procedure SetWinCount;
function GetWinCount(WString: PString): boolean; far;
   begin
   GetWinCount := WString <> nil;  {effectively sets position to first}
   end;                            {*available* window number!        }
var
   Code            : integer;
   PWinNumber      : pointer;
begin
   if WinNumberCollection^.Count = 0 then {if #'s 1 thru 9 have been used}
         WinCount := wnNoNumber
      else
         begin
         PWinNumber := WinNumberCollection^.FirstThat(@GetWinCount);
         WinNumberString := string(PWinNumber^);
         val(WinNumberString, WinCount, Code);
         WinNumberCollection^.Delete(PWinNumber);
         disposestr(PWinNumber);
         end;
end;

constructor ColBackground.Init(var Bounds: TRect; APat: Char; AColor: Byte);
begin
   TBackground.Init(Bounds, APat);
   Color := AColor;
end;

procedure ColBackground.Draw;
var
   B: TDrawBuffer;
begin
   fillchar(B, SizeOf(B),0);
   movechar(B, Pattern, Color, Size.X);
   writeline(0,0,Size.X,Size.Y,B);
end;

procedure BaseApp.TitleScreen;
var
   Dialog  : PDialog;
   R       : TRect;
   Control : Word;
begin
   R.Assign(0,5,33,13);  {Can use origin point of 0 as we are going to set
                          Options to center the dialog anyway!}
   Dialog := New(PDialog, Init(R, 'Title Screen'));
   with Dialog^ do
      begin
      Flags := Flags and not wfMove;     {don't make title screen movable}
      Options := Options or ofCentered;  {center it in any video mode    }
      R.Assign(1, 2, 32, 3);
      Insert(New(PStaticText, Init(R, ^C'Base App V1.0')));
      R.Assign(1, 3, 32, 4);
      Insert(New(PStaticText, Init(R, ^C'(C) 1991 John C. Leon')));
      R.Assign(12, 5, 20, 7);
      Insert(New(PButton, Init(R, ' OK', cmCancel, bfNormal)));
      end;
   Control := Desktop^.ExecView(Dialog);
   dispose(Dialog, Done);
end;

procedure BaseApp.InitMenuBar;
{Help context numbers 0-999 reserved by TVision.  I opt to reserve 1000 for
 some unknown future use!}
var R: TRect;
begin
  GetExtent(R);
  R.B.Y := R.A.Y + 1;
  if ErrorInitializing > 0 then
     MenuBar := New(PMenuBar, Init(R, NewMenu(NewItem('', '', kbNoKey,
                     cmQuit, hcNoContext, nil))))
     else
     MenuBar := New(PMenuBar, Init(R, NewMenu(
       NewSubMenu('~F~ile', 1001, NewMenu(
         NewItem('~B~ase Window', 'F3', kbF3, cmBaseWindow, 1002,
         NewLine(
         NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, 1003,
         nil)))),
      NewSubMenu('~W~indow', 1050, NewMenu(
         NewItem('~S~ize/Move', 'Ctrl-F5', kbCtrlF5, cmResize, 1051,
         NewItem('~Z~oom', 'F5', kbF5, cmZoom, 1052,
         NewItem('~T~ile', '', kbNoKey, cmTile, 1053,
         NewItem('C~a~scade', '', kbNoKey, cmCascade, 1054,
         NewItem('~N~ext', 'F6', kbF6, cmNext, 1055,
         NewItem('~P~revious', 'Shift-F6', kbShiftF6, cmPrev, 1056,
         NewItem('~C~lose', 'Alt-F3', kbAltF3, cmClose, 1057,
         nil)))))))),
      NewSubMenu('~O~ptions', 1060, NewMenu(
         NewItem('~V~ideo Mode', '', kbNoKey, cmSetVideoMode, 1061,
         nil)),
      NewSubMenu('~H~elp', 1070, NewMenu(
         NewItem('~A~bout...', 'F10', kbF10, cmAbout, 1071, nil)),
      nil))
      )))));
end;

procedure BaseApp.InitStatusLine;
var R:TRect;
begin
   GetExtent(R);
   R.A.Y := R.B.Y - 1;
   if ErrorInitializing > 0 then
      StatusLine := New(PHelpStatusLine, Init(R, NewStatusDef(0, $FFFF,
                        NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit, nil),
                        nil)))
      else
      StatusLine := New(PHelpStatusLine, Init(R,
                        NewStatusDef(0, 1000,
                           NewStatusKey('~F1~ Help', kbF1, cmHelp,
                           NewStatusKey('~F10~ Menu', kbF10, cmMenu,
                           NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit,
                           NewStatusKey('~Alt-F3~ Close', kbAltF3, cmClose,
                           nil)))),
                        NewStatusDef(1001, 1009,
                           NewStatusKey('~File~', kbNoKey, cmHelp,
                           NewStatusKey('', kbF10, cmMenu,
                           NewStatusKey('', kbAltF3, cmClose,
                           nil))),
                        NewStatusDef(1050, 1059,
                           NewStatusKey('~Window Controls~', kbNoKey, cmHelp,
                           NewStatusKey('', kbF10, cmMenu,
                           NewStatusKey('', kbAltF3, cmClose,
                           nil))),
                        NewStatusDef(1060, 1069,
                           NewStatusKey('~System Options~', kbNoKey, cmHelp,
                           NewStatusKey('', kbF10, cmMenu,
                           NewStatusKey('', kbAltF3, cmClose,
                           nil))),
                        NewStatusDef(1070, 1079,
                           NewStatusKey('~F1~ Help', kbF1, cmHelp,
                           NewStatusKey('', kbF10, cmMenu,
                           NewStatusKey('', kbAltF3, cmClose,
                           nil))),
                        NewStatusDef(1080, $FFFF,
                           NewStatusKey('~F1~ Help', kbF1, cmHelp,
                           NewStatusKey('~F10~ Menu', kbF10, cmMenu,
                           NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit,
                           NewStatusKey('~Alt-F3~ Close', kbAltF3, cmClose,
                           nil)))),
                        nil))))))));
end;

function THelpStatusLine.Hint(AHelpCtx: word): string;
begin
   case AHelpCtx of
      1001: Hint := 'Base App File Functions';
      1002: Hint := 'Open Base Window';
      1003: Hint := 'Quit Base Application';
      1050: Hint := 'Open, arrange and move between windows';
      1051: Hint := 'Change the size or position of the active window';
      1052: Hint := 'Enlarge or restore the size of the active window';
      1053: Hint := 'Arrange windows on desktop by tiling';
      1054: Hint := 'Arrange windows on desktop by cascading';
      1055: Hint := 'Make the next window active';
      1056: Hint := 'Make the previous window active';
      1057: Hint := 'Close the active window';
      1060: Hint := 'Miscellaneous system options';
      1061: Hint := 'For EGA/VGA only - toggle between normal and 43/50 line mode';
      1070: Hint := '';
      1071: Hint := 'Show title screen, version information';
      1080: Hint := 'Quit Base Application';
      1081: Hint := 'Close all windows and exit Base Application';
   else
      Hint := '';
      end;
end;

constructor BWindow.Init(var Bounds: TRect; WinTitle: string;
                      WinNumber: integer);
begin
   TWindow.Init(Bounds, WinTitle, WinNumber);
   Options := Options or ofTileable; {make 'em tile/cascade}
   EnableCommands([cmTile, cmCascade]);
end;

destructor BWindow.Done;
begin
   if NextView^.NextView = nil then         {If window is last on desktop,   }
      DisableCommands([cmTile, cmCascade]); {then disable tile/cascade cmds. }
   TWindow.Done; {must come *after* if statement above}
   if Number <> wnNoNumber then {i.e. if BWindow.Number <> wnNoNumber}
      begin
      str(Number,WinNumberString);
      WinNumberCollection^.Insert(NewStr(WinNumberString));
      end;
end;

procedure BaseApp.BaseWindow;
var
   Window: PWindow;
   R: TRect;
begin
   GetExtent(R);   {get max dimensions of window}
   R.Grow(-4, 0);  {shrink in X direction};
   R.A.Y := R.A.Y + 2;  R.B.Y := R.B.Y - 4;  {shrink in Y direction}
   SetWinCount;
   Window := New(PWindow, Init(R, 'Base App Window', WinCount));
   Desktop^.Insert(Window);
end;

procedure BaseApp.HandleEvent(var Event: TEvent);
begin
  TApplication.HandleEvent(Event);
  if Event.What = evCommand then
     begin
     case Event.Command of
          cmAbout       : TitleScreen;
          cmTile        : TileAll;
          cmCascade     : CascadeAll;
          cmSetVideoMode: SetVideoMode;
          cmBaseWindow  : BaseWindow;
       else
          Exit;
       end;
     ClearEvent(Event);
     end;
end;

procedure BaseApp.TileAll; {The cmTile and cmCascade commands are disabled }
var                        {at app init, are in place whenever windows are }
   R: TRect;               {open, and are disabled by RepoWindow.Done if   }
begin                      {the window being closed is the last on desktop.}
   DeskTop^.GetExtent(R);
   Desktop^.Tile(R);
end;

procedure BaseApp.CascadeAll;
var
   R: TRect;
begin
   Desktop^.GetExtent(R);
   Desktop^.Cascade(R);
end;

procedure BaseApp.SetVideoMode;
begin
   {During BaseApp.Init we tested for EGA/VGA screen, and DISABLED this
    cmSetVideoMode command (a toggle) for non-EGA/VGA screens.}
   TApplication.SetScreenMode(ScreenMode xor smFont8x8);
end;


begin
   BApp.Init;
   BApp.Run;
   BApp.Done;
end.